Priors
\(\alpha\)
tibble(x = seq(0, 1.3, length = 10^(5)),
y = with(prior_params, gamma_density(x,
mean = alpha_mean,
sd = alpha_sd,
bounds = alpha_bounds))) %>%
ggplot(aes(x=x, y = y)) +
geom_line(alpha = .8) +
geom_ribbon(aes(x=x,ymin=0,ymax=y),
fill="black",
alpha=.6) +
theme_c(legend.text=element_text(size = 10)) +
viridis::scale_fill_viridis(discrete=TRUE,
option = "rocket", begin=.3,end=.8) +
labs(x = "Value",
y = "Probability Density",
title = latex2exp::TeX("Definition of Prior for $\\alpha$"),
fill ='',
subtitle = paste0("Mean: ", prior_params$alpha_mean,
", SD: ", prior_params$alpha_sd))
\(\beta\)
tibble(x = seq(0, 1, length = 10^(5)),
y = with(prior_params, beta_density(x,
mean = beta_mean,
sd = beta_sd,
bounds = beta_bounds))) %>%
ggplot(aes(x=x, y = y)) +
geom_line(alpha = .8) +
geom_ribbon(aes(x=x,ymin=0,ymax=y),
fill="black",
alpha=.6) +
theme_c(legend.text=element_text(size = 10)) +
viridis::scale_fill_viridis(discrete=TRUE,
option = "rocket", begin=.3,end=.8) +
labs(x = "Value",
y = "Probability Density",
title = latex2exp::TeX("Definition of Prior for $\\beta$"),
fill ='',
subtitle = paste0("Mean: ", prior_params$beta_mean,
", SD: ", prior_params$beta_sd))
\(P(S_1|\text{untested})\)
tibble(x = seq(0, 1, length = 10^(5)),
y = with(prior_params, beta_density(x,
mean = s_untested_mean,
sd = s_untested_sd,
bounds = s_untested_bounds))) %>%
ggplot(aes(x=x, y = y)) +
geom_line(alpha = .8) +
geom_ribbon(aes(x=x,ymin=0,ymax=y),
fill="black",
alpha=.6) +
theme_c(legend.text=element_text(size = 10)) +
viridis::scale_fill_viridis(discrete=TRUE,
option = "rocket", begin=.3,end=.8) +
labs(x = "Value",
y = "Probability Density",
title = latex2exp::TeX("Definition of Prior for $P(S_1|untested)$"),
fill ='',
subtitle = paste0("Mean: ", prior_params$s_untested_mean,
", SD: ", prior_params$s_untested_sd))
\(P(S_0| \text{test}_+, \text{untested})\)
tibble(x = seq(0, 1, length = 10^(5)),
y = with(prior_params, beta_density(x,
mean = p_s0_pos_mean,
sd = p_s0_pos_sd,
bounds = p_s0_pos_bounds))) %>%
ggplot(aes(x=x, y = y)) +
geom_line(alpha = .8) +
geom_ribbon(aes(x=x,ymin=0,ymax=y),
fill="black",
alpha=.6) +
theme_c(legend.text=element_text(size = 10)) +
viridis::scale_fill_viridis(discrete=TRUE,
option = "rocket", begin=.3,end=.8) +
labs(x = "Value",
y = "Probability Density",
title = latex2exp::TeX("Definition of Prior for $P(S_0|test_+,untested)$"),
fill ='',
subtitle = paste0("Mean: ", prior_params$p_s0_pos_mean,
", SD: ", prior_params$p_s0_pos_sd))
COVID-19 Trends and Impact Survey
ctis_smoothed <- tar_read(ctis_smoothed,store = here("_targets"))\(\beta\)
ctis_smoothed %>%
filter(keep) %>%
mutate(state=toupper(state)) %>%
select(date,
state,
imputed_beta,
beta_estimate_smoothed,
beta_estimate_spline_smoothed) %>%
pivot_longer(contains("beta")) %>%
mutate(name = case_when(
name == "beta_estimate_smoothed" ~ "LOESS smoothed",
name == "beta_estimate_spline_smoothed" ~ "Spline smoothed",
name == "imputed_beta" ~ "Survey Value"
)) %>%
ggplot(aes(x=date, y=value, color = name,
alpha = name, linewidth=name)) +
geom_line() +
facet_wrap(~state, ncol=4) +
scale_alpha_manual(values=c("LOESS smoothed" = .9,
"Spline smoothed" = .9,
"Survey Value"=.3),
name='') +
scale_linewidth_manual(values = c("LOESS smoothed" = 1.05,
"Spline smoothed" = 1.05,
"Survey Value"=.5)) +
scale_color_manual(values=c("#3381FF", "#B58746", "#26900F"),
name ='') +
guides(alpha="none",
linewidth="none",
color = guide_legend(override.aes = list(linewidth = 3,
alpha = c("LOESS smoothed" = .9,
"Spline smoothed" = .9,
"Survey Value"=.3)),
nrow=3)) +
theme_c(legend.position="top") +
ylim(0,1) +
scale_x_date(date_breaks="3 months",
date_labels = "%b %Y") +
labs(y = TeX("Survey Estimate of $\\beta$"),
x= "",
title = TeX("Comparing Approaches for Smoothing Survey Estimates of $\\beta$"))
The ratio of the screening test positivity over the overall test positivity from the COVID-19 Trends and Impact Survey is taken to be the estimate of \(\beta\). We compare two approaches to smoothing: cubic spline smoothing with 2 knots (July 15th, 2021 and December 1st, 2021) to LOESS smoothing with a span of 0.33.
\(\Pr(S_1 | \text{untested})\)
ctis_smoothed %>%
mutate(state=toupper(state)) %>%
select(date,
state,
contains("s_untested")) %>%
pivot_longer(contains("s_untested")) %>%
mutate(name = case_when(
name == "s_untested_smoothed" ~ "LOESS smoothed",
name == "imputed_s_untested" ~ "Survey Value"
)) %>%
ggplot(aes(x=date, y=value, color = name,
alpha = name, linewidth=name)) +
geom_line() +
facet_wrap(~state, ncol=4) +
scale_alpha_manual(values=c("LOESS smoothed" = .9,
"Survey Value"=.6),
name='') +
scale_linewidth_manual(values = c("LOESS smoothed" = 1.02,
"Survey Value"=.9)) +
scale_color_manual(values=c("Survey Value" ="black", "LOESS smoothed"="darkred"),
name ='') +
guides(alpha="none",
linewidth="none",
color = guide_legend(override.aes = list(
linewidth = 3,
alpha = c("LOESS smoothed" = .9,
"Survey Value"=.3)),
nrow=3)) +
theme_c(legend.position="top") +
scale_x_date(date_breaks="3 months",
date_labels = "%b %Y") +
labs(y = TeX("Survey Estimate of $Pr(S_1|untested)$"),
x= "",
title = TeX("Comparing Approaches for Smoothing Survey Estimates of $Pr(S_1|untested)$"))
The percentage of the population experiencing COVID-19-like illness is taken to be the estimate of $(S_1|). The LOESS smoothed estimate with a span of 0.2 is shown in red.
Distributions of \(\beta\) by State
# raw ctis data
ctis_raw <- readRDS(here('data/data_raw/ctis_all_states.RDS'))
states_keep <- ctis_smoothed %>%
filter(keep) %>% pull(state) %>% unique()
ctis <- ctis_raw %>%
select(signal, state=geo_value, date, value) %>%
pivot_wider(names_from=signal, values_from=value) %>%
filter(state %in% states_keep) %>%
mutate(beta=smoothed_wscreening_tested_positive_14d/
smoothed_wtested_positive_14d,
state=toupper(state))ctis %>%
group_by(state) %>%
summarize(median = median(beta, na.rm=TRUE),
mean = mean(beta, na.rm=TRUE),
q1 = quantile(beta, .025, na.rm=TRUE),
q2 = quantile(beta, .975, na.rm=TRUE)) %>%
ggplot(aes(x= fct_reorder(state, mean, .desc=TRUE),
y = mean)) +
geom_errorbar(aes(ymin=q1,ymax=q2),width=.2) +
geom_point(color="darkred", size=2) +
scale_y_continuous(n.breaks=10) +
labs(y= TeX("Empirical Estimates of $\\beta$"),
x="State",
title = TeX("Empirical Estimates of $\\beta$ from the COVID-19 Trends and Impact Survey"),
subtitle = "2.7% Percentile, 97.5% Percentile, and Mean By State" ) +
theme_c(axis.title=element_text(size=12))
Since \(\beta\) represents the ratio of \(\Pr(\text{test}_+|\text{untested}, S_0)\) to \(\Pr(\text{test}_+|\text{tested})\), we estimate \(\beta\) from the COVID-19 Trends and Impact Survey as the ratio of the screening test positivity over the overall test positivity. Here, we consider the 2.5% and 97.5% percentiles and mean for each state. Most have a mean near \(20%\).
ggsave(here("figures/emp-estimate-beta-dist-by-state.pdf"))ctis %>%
ggplot(aes(x = beta, fill=state)) +
geom_density() +
scale_fill_viridis(option="mako", discrete=TRUE) +
theme_c()
ctis %>%
ggplot(aes(x = beta, fill=state)) +
geom_density() +
scale_fill_viridis(option="mako", discrete=TRUE) +
theme_c() +
facet_wrap(~state)